perm filename ALPHA.F4[P11,LCS]1 blob sn#573356 filedate 1981-03-15 generic text, type T, neo UTF8
00100	C****** FOR LISTS OF LETTERS, ETC. AND TRILL *******
00200		SUBROUTINE ALPHA
00220		INTEGER FNAME,POS
00240		DIMENSION FNAME(4)
00300		COMMON /PLTR/IPLT,RHT,DIS /FONT/JFONT /NFONT/NFONT
00400		COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) 
00405		COMMON/ALF/INP(10),OLDX /OLDTOP/OLDY
00500	       EQUIVALENCE(J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R5,RJQ(3)),
00600		1(R8,RJQ(6)),(NRJ,RJQ(8)),(JX,JQ(11)),
00700		1(R6,RJQ(4)),(J7,JQ(5)),(J8,JQ(6)),(J9,JQ(7)),(J10,JQ(8))
00800		1,(J6,JQ(4)),(R7,RJQ(5)),(R4,RJQ(2)),(IFNT,JQ(13)),(J11,JQ(9)),
00900		1(RY,JQ(16)),(RX,JQ(17)),(RZ,JQ(18)),(RW
01000		1,JQ(19)),(RB,JQ(20)),(R,RJQ(20)),(FILL,RJQ(19)),(R9,RJQ(7))
01100		1,(JTR,RJQ(17)),(RF,RJQ(15)),(JR3,RJQ(14)),(R3,RJQ(1))
01200		1,(R10,RJQ(8)),(R11,RJQ(9)),(R12,RJQ(10))
01300		COMMON/STF/RSTFAC(8),RSTJ2 /POSI/STFF(8),JJ2,POS
01400		DATA R4X/-2.1/,IFNT/1/,BLANK/0.7/,NFONT/'BDR40'/
01420		1,FNAME/'PRIM0','BDR40','BDI40','BDL40'/
01450	C  SEE NEW SIZE FOR 'BLANK'=.7 (OLD SIZE=1.0, CHANGE IN DDT IF NECESSARY)
01500	
01600		IF(JA.EQ.7)GO TO 20
01700		JTR=99
01800		IF(R5.GE.100)R5=R5-100
01900	C >100 FOR TEXT IN ORCH SCORES FOR ALL SEP. PARTS.
02000	C  PRIMITIVE IS DEFAULT FONT.  #=SET BACK TO PRIM.
02100	C ONLY 11 LETTERS WITHOUT FONT RESET.
02110		JF=-JFONT
02120		IF(JFONT.GE.0)GO TO 540
02140		JFONT=1
02160		NFONT=FNAME(JF)
02180		GO TO 54
02200	540	IF(NFONT.EQ.'PRIM0')GO TO 54
02300		IF(NFONT.EQ.'BDI40')GO TO 54
02400		NFONT='BDR40'
02500	C  THE ABOVE IN CASE FONT IS NOT ESTABLISHED.
02600	54	R=19.7*R5*RSTJ2
02700		RB=J3
02800		RW=R4
02900		J9=0
03000	C J9=0 AVOIDS ROTATION IN 'CLEFS'
03100		DO 50 KA=4,6
03200		NXZ=-1
03300		RZ=RJQ(KA)
03400	CC	JY=RZ
03500	CC	IF(JY.NE.RZ)GO TO 130
03600	CC	IF(JY.EQ.RZ)GO TO 13
03700	C  WILL LOSE ON "0AB0" IN OLD FILES**************
03800	CC	IF(JY.GT.999999)GO TO 13
03900	CC130	RZ=100.*RZ
04000	C  FOR OLD FORMAT OF CODE 16
04100	13	JY=RZ+.2
04200		JX=1000000
04300		DO 53 LA=1,4
04400		J5=JY/JX
04500		J5X=J5
04600		R3=J3
04700		IF(J5.EQ.99)GO TO 55
04800	73	IF(KFNT)IFNT=1
04900	C READS OLD SYS. AND NEW AUTOMATIC LWR CASE.
05000		IF(J5.LT.70)GO TO 72
05100		KFNT=-1
05200	C  SETS AUTOMATIC LOWER CASE FLAG.
05300		IFNT=-1
05400	C  60 ADDED FOR LOWER CASE LETTERS.
05500		J5=J5-60
05600	C NO MORE IN THIS WD.
05700	72	IF(J5.LT.48)GO TO 1
05750		IF(J5.NE.48)GO TO 172
05775		NFONT='BDL40'
05787		IF(JFONT.LT.0)GO TO 9
05793		GO TO 11
05800	172	GO TO(2,3,9,4,5),J5-49
05900	C SWITCHES FOR DIFF. FONTS.(55 MAKES ')48=UPR,49=LWR,50=BDR,51=BDI,52=PRM
06000	C  ********* UPPER AND LOWER NUMBERS(48,49) NO LONGER NEEDED.(SEE 73 ↑)
06100		IF(J5.GT.55)GO TO 10
06200		J5=36
06300		R4=R4+2.9*R5
06400	C  55 WILL MAKE ' --- 56=?  57=! (THEY COME AFTER y z IN BDR46)
06500		GO TO 1
06600	10	J5=J5+6 
06700		NRX=NFONT
06800		NXZ=0 
06900		NFONT='BDR40'
07000		NJF=JFONT
07100		JFONT=-1
07200		GO TO 1
07300	2	NFONT='BDR40'
07400	C  &=NON-ITALICS  --  JFONT IS TEMPORARY SWITCH  5/74
07500		IF(JFONT.LT.0)GO TO 9
07600		GO TO 11
07700	CC	GO TO 8
07800	3	NFONT='BDI40'
07900	C  @=51=ITALICS
08000		IF(JFONT.LT.0)GO TO 9
08100	C  TYPE '44 -1' TO MAKE ALL FONTS INTO 'PRIM'
08200	CC8	IF(IFNT.EQ.0)IFNT=-1
08300		GO TO 11
08400	4	FILL=-2
08500		GO TO 11
08600	5	FILL=0
08700		GO TO 11
08800	9	NFONT='PRIM0'
08900		GO TO 11
08905	1	IF(J5.LT.70)GO TO 12
08910		IF(J5.GE.76)GO TO 12
08915		IF(J5.NE.75)GO TO 112
08920		J5=70
08925		GO TO 12
08930	112	NFONT='BDI40'
08935		J5=J5-6
08940		GO TO 71
08945	12	J5OLD=J5
08950		IF(J5.LT.64)GO TO 212
08955		J5X=J5
08960		IF(J5.LE.65)J5X=J5X-6
08965		IF(J5.EQ.70)J5X=J5X-1
08970		J5=J5X
09000	212	CALL SPACER(J5,IFNT,RB,R)
09100		IF(J5.GT.60)GO TO 71
09200	C  NOW 62=?  63=!  IN BDR46
09300		IF(J5-47)7,6,11
09330	7	IF(R11.NE.0.AND.R12.EQ.0)GO TO 79
09400		IF(JFONT)78,78,77
09460	79	R9=R11
09470		J9=-1
09471	C  FOR ROTATION, IF ANY.  R11=ROTATION(CLOCKWISE) IN DEGREES.
09487		GO TO 77
09500	277	IF(NFONT.NE.'PRIM0')GO TO 70
09505		IF(IFNT.GE.0)GO TO 30
09510		IF(J5.GE.10)GO TO 71
09515		GO TO 30
09520	177	J5=J5+22
09525	C (=62 )=63 IN BDI  (BDI46)
09530		NRX=NFONT
09535	C  SAVE OLD FILE NAME
09540		NFONT='BDI40'
09545		NJF=JFONT
09550	C SAVE FONT FLAG
09555		NXZ=0
09560	C FLAG TO GET BACK RIGHT FLAGS BEFORE 30
09565		GO TO 71
09680	78	IF(IPLT.GE.0)GO TO 30
09685	C  JFONT=0 FOR FIXED WIDTH OF FONTS.  = AND ONLY DPYS PRIMITIVE.
09700	CC	J5=J6
09800	CC	IF(IFNT.EQ.0)GO TO 30
09900	CC77	IF(J5.GE.36)GO TO 30
09905	77	IF(J5.LT.36)GO TO 277
09910		IF(J5.EQ.40.OR.J5.EQ.41)GO TO 177
09912	C FOR LEFT AND RIGHT PARENTH.
09915		IF(J5.NE.43)GO TO 30
09920	C ASTERISK
10000	C  PUNCTUATION AND SPACE.
10100		IF(NFONT.EQ.'PRIM0')GO TO 30
10105		IF(NFONT.EQ.'BDI40')GO TO 77
10110		NRX=NFONT
10115		NXZ=0
10120		NJF=J5
10125		NFONT='BDI40'
10130	777	J5=69
10135		GO TO 71
10200	CZ	IF(IFNT.GE.0)GO TO 30
10300	CC*** WAS (IFNT.EQ.1) ????  1/76
10400	CZ	IF(J5.LT.10)GO TO 30
10500	C  JUMP TO USE UPPER CASE PRIM. LOWER CASE STARTS IN PRIM1.
10600	CZ	GO TO 71
10700	70	IF(J5.LE.9)GO TO 71
10800		IF(IFNT.LT.0)J5=J5+26
10900	71	RX=R6
11000		R6=R5*.28
11100	C  .29 IS SIZE FACTOR -- PERHAPS CHANGE SIZE IN FONT TO =1.
11200		RY=R7
11300		R7=R6
11400		RZ=R8
11500		R4=R4+R4X
11600	C  SHIFTS DOWN ??? WHY NOT GET RID OF THIS.??
11700		J8=FILL
11800		NRJ=NFONT
11900	C  GETS RIGHT FILE
11905		R8=0
11910	C  TO AVOID THICKENER IN 'CLEFS'
12000		JA=12
12100	C  ANY NON-11 NUMBER .GT.10 WILL DO.
12300		CALL CLEFS
12400		R6=RX
12500		R7=RY
12600		R8=RZ
12700	C  PUTS BACK RIGHT STUFF
12800		IF(NXZ.LT.0)GO TO 6	
12900		NFONT=NRX
13000		JFONT=NJF
13100		GO TO 6
13200	
13300	30	J7=0
13400		R6=R5
13500		CALL PNUM
13600	C  47=BLANK  (WAS 99)
13700	6	J3=ROFF(RB)
13800		R4=RW
13900	11	JY=JY-J5X*JX
14000	C TO GET NEXT NUM OUT OF JY
14100	53	JX=JX/100
14200	50	CONTINUE
14300	55	IF(JTR.NE.99)GO TO 52
14305		NSAV=NFONT
14310		GO TO 100
14500	
14700	C  FOR TRILLS
14800	C  7, POS1, STF, NT#, SIZE, POS2, X     IF X=1 THEN NO WAVEY LINE
14900	20	RF=R6
14905		NSAV=NFONT
14910	C SAVE THE FONT NAME.  GET IT BACK AT END.
14915		JTRILL=J7
15000		IF(J7.LE.1)GO TO 200
15100		IF(J7.GE.8)GO TO 201
15200	C JUMP FOR OTTAVA
15300	C  NEXT FOR SPECIAL PEDAL MARKS.
15400	
15500	C PEDAL: 7,STF,POS,0=STND POS,NNN=PEDS,POS2,BRACK #S,LFT POS BRK.
15600	C P5=101 MEANS LFT & RT PEDS., P7=2 NO BRK, =3 --!, =4 ----
15700		RW=R8
15800		RB=R3
15900		NFONT=J7
16000		JY=J5
16100		CALL NOZERO(R9)
16200		RY=R9
16300		RX=23.84*R9*RSTJ2
16400		R6=.45*RY
16500		J9=0
16600		J5=18
16700	C  IN FILE CLEF1.DMD
16800		JA=3
16900		R5=0
17000		R7=0
17100		R4=R4-6
17200	C  STANDARD POS IS AT -6 ******  (I.E. P4=0 PUTS TOP OF IT AT -6)
17300		CALL CLEFS
17305		R8=0
17400		IF(JY.EQ.0)GO TO 222
17500		R8=-1
17600		J5=19
17700		IF(JY.LT.100)GO TO 203
17800		JY=JY-100
17900		CALL CLEFS
18000	203	R3=RB+RX
18100		IF(JY.LT.10)GO TO 204
18200		JY=JY-10
18300		CALL CLEFS
18400	204	R3=RB+RX+RX
18500		IF(JY.NE.0)CALL CLEFS
18600	C PRINTS THE 3 BOTTOM ITEMS
18700	
18800	222	IF(NFONT.EQ.2)GO TO 2222
18900		IF(RW.NE.0)R3=RB-5.96*RW
19000	C  FOR BRACKET
19100		RX=POS
19200		R6=RF
19300		R4=R4+3.
19400		R5=R4
19500		J7=0
19600		R7=0
19700		R8=0
19800		R10=0
19900	206	CALL ITMSUB
20000		IF(NFONT.EQ.4)GO TO 2222
20100	C  R7=4= NO END ON BRKT.
20105		IF(NFONT.EQ.5)GO TO 2206
20110		OLDY=10.*RY*RSTJ2
20112	C THIS WILL BE VERTICAL PART OF BRACK. END.
20113	C THE  COORD. FROM LAST LINES CALL
20115		CALL LINES(OLDX,OLDY,2)
20120	C OLDX WAS LAST X COORD. IN ITMSUB **************
20125		GO TO 2222
20200	CZ	POS=RX
20300	C  POS GOT RUINED IN ITMSUB.
20400	CZ	R3=ROFF(RHORZ(RF))
20500	CZ	R5=R5+1.4*RY
20600	CZ	CALL ITMSUB
20700	CZ	RETURN
20800	
20805	2206	RARR=2.25*RY*RSTJ2
20810		R4=R4+2.12
20815		JA=4
20820		J5=50
20825	C  FOR CRESC.
20830		RYY=1.29*RY
20835		R6=RF
20840		R3=(R6-RARR)*5.96-596.
20845		R7=-RYY
20850		CALL ITMSUB
20852	C GO DRAW CRESC.
20855		GO TO 2222
20900	C  NEXT FOR 8VA BASSA
21000	202	R7=47717088.
21100		R8=88709999.
21200		RR10=138.
21300		R6=51089170.
21400		GO TO 214
21500	201	CALL NOZERO(R5)
21600		IF(J7.EQ.15)GO TO 205
21700		R6=51089170.
21800	C NEXT = 8VA
21900		RR10=47.
22000		R7=99999999.0
22100	214	RR5=R5*RSTJ2
22200		RR3=R3+RR10*RR5
22300	C  SAVE FOR POS. OF DASHES
22400		JTR=-1
22500		J4=J7
22600		J10=J8
22700	C SAVE THESE IN PARAMS NOT USED IN ALPHA
22800		GO TO 2212
22900	
23000	C  15MA - - - - -
23100	205	R6=51010582.
23200		R7=70999999.
23300		RR10=56.
23400		GO TO 214
23500	
23600	C NEXT FOR THE DASHES. J8=1 =NO END BRACK.
23700	213	R8=1.8*RR5
23800		R9=0
23900		R3=RR3
24000		R6=RF
24100		R4=R4+.7*RSTJ2
24200		R5=R4
24300		J5=J4
24400		J11=-1
24500		IF(J4)J11=-J11
24600		IF(J10.NE.0)J11=0
24700		J7=1
24800		J10=0
24900	C  GO DRAW THE DASHES
25000		CALL ITMSUB
25100		GO TO 2222
25200	
25300	200	CALL NOZERO(R5)
25400		IF(J7.EQ.-8)GO TO 202
25500		RR10=R5
25600	C  ↑↑↑↑↑ R10 GETS WIPED OUT IN ALPHA OR CLEFS.
25700		J3=J3+6.*RSTJ2
25800		JR3=J3
25900		R6=51898799.0
26000	C  @tr  LWR CASE, ITAL.  TR
26100		R7=0
26200		R8=R7
26300		JTR=J7
26400	2212	R5=.8*R5
26500		GO TO 54
26600	52	J5=R8
26650	C FOR ACCI OVER TR
26662		K=POS
26668	C  SAVE POS IN K FOR ACCI ROUTINE
26675		IF(JTR.NE.0)GO TO 1000
26700	C   GO TO 100 IF NO WAVY LINE IS NEEDED. J7=1=NO, 0=YES
26800		R3=JR3+20.*RSTJ2*RR10
26900		JA=4
27000		J7=-2
27100	C  J7 IS SWITCH TO DRAW WIGGLE
27200		R6=RF
27300		R9=.7*RR10
27400	C  SETS WIGGLE HEIGHT
27500		R8=.9*RR10
27600	C  RR10 IS SIZE (P5)
27700		J10=0
27800		IF(IPLT.LT.0)J10=1
27900		CALL ITMSUB
28000	C  SINGLE WIGGLE ON DPY, DOUBLE ON PLOTTER.
28010	1000	IF(JTRILL.LT.0.OR.JTRILL.GT.1)GO TO 100
28020	C NEXT PUTS ACCI OVER TR IF 1, 2 OR 3 IN P8
28030	C IF JTRILL(J7)=0 OF 1 IT'S A TRILL, ELSE GO TO 2222
28040	C IF R8=0 GOTO 2222 (R8 HAS ACCI NUM)
28050		IF(R8.EQ.0)GO TO 100
28060		POS=K
28070	C GET BACK POS. (IT GOT CHANGED IN "WIGGLE")
28080		CENTR=CENTR+27.*RSTJ2
28090		R6=R5*.9
28100		R3=J3-14.*RSTJ2
28110		R4=R4+3.75
28120		R7=0
28130		R8=0
28140		R9=0
28150		JA=9
28160	C NOW GO MAKE AN ACCI.
28170		CALL NOTWRT
28250	100	IF(JTR.LT.0)GO TO 213
28275		IF(KFNT.LT.0)IFNT=1
28300		KFNT=0
28400	2222	NFONT=NSAV
28410	C GET BACK ORIGINAL FONT NAME
28420		END